uses Crt,Dos;
const
 shift=$100; {Смещение относительно сегмента для com файла}
 tInteger=1; {Указатели на типы}
 tWord=2;
 tByte=3;
 tChar=4;
 Types:array[1..4]of record {Определение типа переменной}
  Name:String[7];  {Имя типа переменной}
  Size:byte;  {Размер переменной}
  Arif:boolean; {Выполнение арифметических операций}
     end=((Name:'INTEGER';Size:2;Arif:true), {Присвваивание начальных зачений}
          (Name:'WORD';Size:2;Arif:true),
          (Name:'BYTE';Size:1;Arif:true),
          (Name:'CHAR';Size:1;Arif:false));
 Digits: set of char=['0'..'9'];  {Допустимые цыфры}
 Liters: set of char=['A'..'Z'];  {Допустимые литеры}
 Dividers: set of char=['+','-','*','/',':','.',';','=','[',']','(',')',
                        '<','>','"']; {Используемые символы}
 SSize=48;
var
 InpStr:array[0..4096]of char; {Входной файл}
 OutStr:array[0..4096]of byte; {Выходной com файл}
 OutPtr:word; {Указатель на записываемый байт в outstr}
 InpFileName,FName,FExt,Path:string; {Переменные определения имени входного файла}
 OutFileName:string;  {Имя выходного файла}
 InpF,OutF:file;  {Файловые переменные, чтения и записи}
 InpSize,InpPtr:word; {Размеры файлов}
 Result:integer;
 CurWord:string; {Текущее слово}
 VarTabl:record  {Таблица переменных}
   Field:array[1..1000]of record {}
          Name:String[16]; {Имя переменной}
          Tip:byte; {Тип переменной}
          Size:word; {Размер переменной}
          Adr:word; {Адресс переменной}
         end;
   FieldNum:word; {Номер последеней переменной в таблице}
 end;
 Address:word;
 I:word;
 Stack:array[1..10000]of word; {Стек программы}
 StackPtr:word; {Указатель   на стек}
 DataBase:word;
 TmpInt:integer;
 StrNum:Word;
 ReadAdr:word;
procedure Prog;forward;  {Определение глобальных процедур}
procedure Stmt;forward;
procedure Opers;forward;
procedure Xprs;forward;
procedure X2;forward;
procedure X3;forward;
procedure Vars;forward;

procedure Error(Code:byte;Msg:string); {Процедура печати ошибки}
begin
 case code of
  1:Write('Повторное определение переменной ',Msg);
  2:Write('Ожидается символ "',Msg,'"');
  3:Write('Ожидается слово ',Msg);
  4:Write('Неправильно указан ',Msg);
  5:Write('Ожидается ',Msg);
  6:Write('Неверный формат ',Msg);
  7:Write('Неверный тип операнда');
  8:Write('Неизвестный идентификатор ',Msg);
  9:Write('Ожидается переменная типа ',Msg);
  10:Write('Неизвестный символ: "',Msg,'"');
 end;
  WriteLn(' ( cтрока ', StrNum,' )');
  WriteLn('последнее считанное слово: ',CurWord);
 Halt(1);
end;
{============================WRITE1============================}
procedure Write1(Bt:byte); {Запись в выходную строку кода}
begin
 OutStr[OutPtr]:=Bt;
 Inc(OutPtr);
end;
{============================WRITE2============================}
procedure Write2(Bt1,Bt2:byte); {Запись в выходную строку кода}
begin
 OutStr[OutPtr]:=Bt1;
 OutStr[OutPtr+1]:=Bt2;
 Inc(OutPtr,2);
end;
{============================WRITE3============================}
procedure Write3(Bt1,Bt2,Bt3:byte); {Запись в выходную строку кода}
begin
 OutStr[OutPtr]:=Bt1;
 OutStr[OutPtr+1]:=Bt2;
 OutStr[OutPtr+2]:=Bt3;
 Inc(OutPtr,3);
end;
{============================WRITE4============================}
procedure Write4(Bt1,Bt2,Bt3,Bt4:byte); {Запись в выходную строку кода}
begin
 OutStr[OutPtr]:=Bt1;
 OutStr[OutPtr+1]:=Bt2;
 OutStr[OutPtr+2]:=Bt3;
 OutStr[OutPtr+3]:=Bt4;
 Inc(OutPtr,4);
end;
{===============================ToStack============================}
procedure ToStack(Param:word);  {Запись слова в стек}
begin
 Stack[StackPtr]:=Param;
 Inc(StackPtr);
end;
{===============================FromStack==========================}
function FromStack:Word; {Извлечение слова из стека}
begin
 Dec(StackPtr);
 FromStack:=Stack[StackPtr];
end;
{===============================NEXT WORD==========================}
function NextWord:string; {Вырезает слово из программы}
var tmp:string;
begin
 Tmp:='';
 while (InpStr[InpPtr]in [#10,#13,' ','}','{']) do
  begin
   while InpStr[InpPtr] in [#10,#13,' ','}'] do
    begin
     if InpStr[InpPtr] =#10 then Inc(StrNum);
     inc (InpPtr);
    end;
   if InpStr[InpPtr]='{' then {Пропускаем комментарии}
     while InpStr[InpPtr]<>'}' do
    begin
     if InpStr[InpPtr] =#10 then Inc(StrNum);
     inc (InpPtr);
    end;
  end;
 if InpStr[InpPtr] in digits then  {Если число}
  while InpStr[InpPtr] in Digits do
   begin
    Tmp:=Tmp+InpStr[InpPtr]; {Формирование строки}
    inc(InpPtr)
   end
 else
 if InpStr[InpPtr] in dividers then {Если управляющий символ}
  begin
    Tmp:=InpStr[InpPtr]; {Формирование строки}
    inc(InpPtr);
  end
 else
 if UpCase(InpStr[InpPtr]) in Liters then {Перевод в верхний регист и чтение слова}
  while UpCase(InpStr[InpPtr]) in Digits+Liters do
   begin
    Tmp:=Tmp+UpCase(InpStr[InpPtr]); {Формирование строки}
    inc(InpPtr)
   end
 else Error(10,InpStr[InpPtr])  ;
 NextWord:=Tmp;
end;
{================================InId=========================}
function InId(Name:string):word; {Проверка на нахождение переменной}
var I:word;
begin
  InId:=0;
  for I:=1 to VarTabl.FieldNum do
   if VarTabl.Field[I].Name=Name then InId:=I;
end;
{==============================OutInt==========================}
procedure OutInt; {Код печати числа на экран}
var retpoint:word;
begin
 write1($50);
 write3($BF,$41,$01);
 write3($B9,$06,$00);
 write2($B0,$20);
 write2($F3,$AA);
 write1($58);
 write3($BF,$46,$01);
 write3($B9,$0A,$00);
 write2($B3,$20);
 write3($80,$FE,$00);
 write2($74,$09);
 write3($3D,$00,$00);
 write2($79,$04);
 write2($B3,$2D);
 write2($F7,$D8);
 write3($BA,$00,$00);
 write2($F7,$F1);
 write3($80,$CA,$30);
 write2($88,$15);
 write1($4F);
 write2($3C,$00);
 write2($75,$F1);
 write2($88,$1D);
 write3($BA,$41,$01);
 write2($B4,$09);
 write2($CD,$21);
 write1($C3);
 write3($2B,$2B,$2B);
 write4($2B,$2B,$2B,$24);
 write1($00);
end;
{----------------------ReadInt---------------------------------}
procedure ReadInt; {Код ввода значения переменной}
var BufAdr:word;
begin
 write2($EB,$0A);
 BufAdr:=OutPtr+shift;
 write3($07,$2E,$2E);   {буфер}
 write4($2E,$2E,$2E,$2E);
 write3($2E,$2E,$90);

 write3($BA,Lo(BufAdr),Hi(BufAdr));  {чистаемая строка}
 write2($B0,$0A);
 write2($B4,$0C);
 write2($CD,$21);

 write3($B8,0,0);
 write3($B9,$0A,$00);
 write3($BB,$02,$00);
 write4($8A,$97,Lo(BufAdr),Hi(BufAdr));
 write3($80,$FA,$2D);
 write2($75,$01);
 write1($43);
 write4($80,$BF,Lo(BufAdr),Hi(BufAdr));write1($0D);
 write2($74,$10);
 write2($F7,$E1);
 write4($8A,$97,Lo(BufAdr),Hi(BufAdr));
 write3($80,$F2,$30);
 write2($B6,$00);
 write2($03,$C2);
 write1($43);
 write2($EB,$E9);
 write4($80,$3E,Lo(BufAdr+2),Hi(BufAdr+2));write1($2D);
 write2($75,$02);
 write2($F7,$D8);
 write1($C3);
end;
{----------------------MakeCompare-----------------------------}
procedure MakeCompare; {Формирование кода сравнения}
var    First,Second:char;
begin
   XPRS;
    Write1($50);                                         {Push AX}
    if CurWord[1] in ['<','>','='] then first:=CurWord[1];
    CurWord:=NextWord;
    if CurWord[1] in ['<','>','='] then
     begin
      Second:=CurWord[1];
      CurWord:=NextWord;
     end
    else Second:=' ';
    XPRS;
    Write1($5B);                                         {Pop BX}
    Write1($93);
    Write2($3B,$C3);                                     {cmp AX,BX}
    Case First of
     '=':Write2($74,$03);                                {je IFlb}
     '>':Case Second of
          ' ':Write2($7F,$03);                           {jg}
          '=':Write2($7D,$03);                           {jge}
         end;
     '<':case Second of
          ' ':Write2($7C,$03);
          '=':Write2($7E,$03);
          '>':Write2($75,$03);
         end;
    end;
end;
{================================Prog==========================}
procedure Prog; {Программа компилировнания начального кода программы}
var retpoint:word;
 begin
  CurWord:=NextWord; {Вырезаем текущее слово}
  if CurWord='DEFINE' then {Обнаружено слово Define}
   begin
    Vars;        {Запускаем процедуру записи в массив переменной}
    DataBase:=$FFFE-Address;   {Установка стека}
    Write3($BC,Lo(DataBase),Hi(DataBase));   {mov SP,0FFFEh-Address}

    write3($E9,$00,$00);
    retpoint:=OutPtr;
    OutInt;
    ReadAdr:=OutPtr;
    ReadInt;
    OutStr[retpoint-2]:=Lo(OutPtr-RetPoint);
    OutStr[retpoint-1]:=Hi(OutPtr-RetPoint);;

    if CurWord='BEGIN' then  {Запускаем проверку слова begin}
     begin
      Stmt;
      if CurWord<>'END' then Error(3,'end'); {Проверка на конец программы}
      if NextWord<>'.' then Error(3,'.');
     end
    else Error(3,' begin');
   end
    else Error(3,' define');

   Write1($90);
   Write3($B8,$00,$4C);
   Write2($CD,$21);
 end;
{===========================VARS==============================}
procedure Vars; {Проверка переменных}
var I:integer;
    NewName:string;
    NewNum:byte;
    Code,NewSize:integer;
 begin
  CurWord:=NextWord;
  if InId(CurWord)<>0 then Error(1,CurWord)
  else
   begin
    NewName:=CurWord;
    if NextWord<>':' then Error(2,':'); {Проверка ":"}
    CurWord:=NextWord;
    NewNum:=0;
    for i:=1 to 4 do
     if CurWord=Types[i].Name then NewNum:=i; {Провека типа переменной}
    if NewNum=0 then Error(4,'тип');
    CurWord:=NextWord;
    if CurWord<>';' then
     if CurWord<>'[' then Error(2,'[')  {Проверка на определение масива}
     else
      begin
       Curword:=NextWord;
       Val(CurWord,NewSize,Code); {Ошибка перевода числа}
       if (Code<>0) or (NewSize<1) then Error(5,'натуральное число');
       If NextWord<>']' then Error(2,']');
       If NextWord<>';' then Error(2,';');
      end
     else NewSize:=1;
     with VarTabl do
      begin
       Inc(FieldNum);   {Запись переменной в массив}
       Field[FieldNum].Name:=NewName; {Имя переменной}
       Field[FieldNum].Tip:=NewNum;   {Тип переменной}
       Field[FieldNum].Size:=NewSize; {Размер переменной}
       Field[FieldNum].Adr:=Address;  {Адресс нахождения переменной}
       Inc(Address,Field[FieldNum].Size*Types[Field[FieldNum].Tip].Size);
      end;
   end ;
   CurWord:=NextWord;              {Проверка на следующую переменную}
   if CurWord='DEFINE' then Vars;
 end;
{===========================STMT==============================}
procedure Stmt; {Структура begin end}
 begin
  CurWord:=NextWord;
  While CurWord<>'END' do {Делать пока не конец программы}
   OPERS {Запуск процедры компилирования комманд}
 end;

{===============================Opers========================}
procedure Opers;    {Расспознование и компилирования комманд}
var NewName:string;
    Tmp,NewNum:word;
    VarPos:word;
    StrBeg:word;
    IfPtr,ElsePtr,WhilePtr1,WhilePtr2:word;
    ToEnd,ToBegin:word;
 begin

  if CurWord='PRINTI' then {вывод числа со знаком}
   begin
    CurWord:=NextWord;
    XPRS;              {Компилирование параметра}
    Write2($B6,$01);
    TmpInt:=OutPtr-3;
    TmpInt:=-TmpInt;
    Write3($E8,Lo(TmpInt),Hi(TmpInt));
   end
  else
  if CurWord='PRINTW' then {вывод числа без знака}
   begin
    CurWord:=NextWord;
    XPRS;             {Компилирование параметра}
    Write2($B6,$00);
    TmpInt:=OutPtr-3;
    TmpInt:=-TmpInt;
    Write3($E8,Lo(TmpInt),Hi(TmpInt));
   end
  else
  if CurWord='PRINTS' then {вывод строки - константы}
   begin
     If NextWord<>'(' then error(2,'('); {Проверки на ошибки в программе}
     If NextWord<>'"' then error(2,'"');
     Inc(OutPtr,2);
     StrBeg:=OutPtr;
     while InpStr[InpPtr]<>'"' do    {Чтение параметра в виде строки}
      begin
       Write1(Ord(InpStr[InpPtr]));
       Inc(InpPtr)
      end;
     inc(InpPtr);
     CurWord:=NextWord;
     if CurWord='L'then    {Проверка на перевод строки}
      begin
       CurWord:=NextWord;
       Write2(13,10);
      end;
     Write1(Ord('$'));  {Запись признака конца строки}
     if CurWord<>')' then error(2,')');  {Проверка на закрывающие скобки}
     OutStr[StrBeg-2]:=$EB;                           {jmp short}
     OutStr[StrBeg-1]:=OutPtr-StrBeg;
     Write3($BA,Lo(StrBeg+shift),Hi(StrBeg+shift));
     Write3($B8,$00,$09);   {запись кода программы}
     Write2($CD,$21);
     CurWord:=NextWord;
   end
  else
  if CurWord='BEGIN' then              {begin}
   begin
    CurWord:=NextWord;
    while CurWord<>'END' do
     begin
      Opers;      {Рекурсивный запуск распознования}
     end;
    CurWord:=NextWord;
   end
  else
  if CurWord='IF'then              {IF}
   begin
    CurWord:=NextWord;
    MakeCompare;            {Проверка сравнения}
    Write3($E9,0,0);
    IfPtr:=OutPtr;
    If CurWord <> 'THEN' then Error(3,'then');
    CurWord:=NextWord;
    Opers;         {Рекурсивный запуск распознования}
    if CurWord='ELSE' then
     begin
      Write3($E9,0,0);
      ElsePtr:=OutPtr;
     end
    else ElsePtr:=0;
    OutStr[IfPtr-2]:=Lo(OutPtr-IfPtr);  {Запись кода перехода если есть else}
    OutStr[IfPtr-1]:=Hi(OutPtr-IfPtr);
    if ElsePtr<>0 then
     begin
      CurWord:=NextWord;
      Opers;      {Рекурсивный запуск распознования}
      OutStr[ElsePtr-2]:=Lo(OutPtr-ElsePtr);
      OutStr[ElsePtr-1]:=Hi(OutPtr-ElsePtr);
     end;
   end
  else
  if CurWord='WHILE'then              {WHILE}
   begin
    CurWord:=NextWord;
    WhilePtr1:=OutPtr;
    MakeCompare;      {Проверка выхода}
    Write3($E9,0,0);
    WhilePtr2:=OutPtr;
    If CurWord <> 'DO' then Error(3,'do'); {Проверка правильности записи}
    CurWord:=NextWord;
    Opers;      {Рекурсивный запуск распознования}
    TmpInt:=OutPtr-WhilePtr1+3;
    TmpInt:=-TmpInt;
    Write3($E9,Lo(TmpInt),Hi(TmpInt)); {Подстановка переходов}
    OutStr[WhilePtr2-2]:=Lo(OutPtr-WhilePtr2);
    OutStr[WhilePtr2-1]:=Hi(OutPtr-WhilePtr2);
   end
  else
  if CurWord='FOR' then                           {For}
   begin
     CurWord:=NextWord;
     NewName:=CurWord;
     NewNum:=InId(CurWord);      {Проверка определения переменной}
     if NewNum=0 then Error(8,CurWord);
     if VarTabl.Field[NewNum].Tip<>1 then Error(9,'integer');
     if NextWord<>'=' then Error(2,'='); {Проверка параметра}
     CurWord:=NextWord;
     XPRS;  {Компилирование выражений}
     Tmp:=VarTabl.Field[NewNum].Adr;
     Write3($A3,Lo(DataBase+Tmp),Hi(DataBase+Tmp)); {mov I,AX}
     if CurWord<>'TO' then Error(3,'to'); {Проверка слова TO}
     ToBegin:=OutPtr;
     CurWord:=NextWord;
     XPRS;   {Компилирование выражений}
     Write4($3B,$06,Lo(DataBase+Tmp),Hi(DataBase+Tmp));
     Write2($7D,$03);
     Write3($E9,0,0);
     ToEnd:=OutPtr;
     if CurWord<>'DO' then Error(3,'do'); {Проверка слова DO}
     CurWord:=NextWord;
     Opers;   {Рекурсивный запуск распознования}
     Write4($FF,$06,Lo(DataBase+Tmp),Hi(DataBase+Tmp)); {Inc I}
     TmpInt:=OutPtr-ToBegin+3;
     TmpInt:=-TmpInt;
     Write3($E9,Lo(TmpInt),Hi(TmpInt));
     OutStr[ToEnd-2]:=Lo(OutPtr-ToEnd);
     OutStr[ToEnd-1]:=Hi(OutPtr-ToEnd);
   end
  else
  if InId(CurWord)<>0 then    {=}
   begin
   NewName:=CurWord;
   with Types[VarTabl.Field[InId(NewName)].Tip] do
   begin
     CurWord:=NextWord;
     if CurWord='[' then {Проверка заполнения элемента массива}
      begin
         CurWord:=NextWord;
         XPRS;    {Компилирование выражения}
         Write3($2D,$01,$00);
         if Size=2 then Write2($D1,$E0);              {SHL AX,1}
         if CurWord<>']' then Error(2,']');
         CurWord:=NextWord;
      end
     else Write2($2B,$C0); {Проверка на присваивание}
     if CurWord<>'=' then Error(2,'=');
     CurWord:=NextWord;
     Write1($50);                                     {Push AX}

     if Arif then XPRS
     else
      begin
       if CurWord<>'"' then Error(2,'"'); {Провекра на символьную переменную}
       XPRS;
      end;
     Write1($5B);                                     {Pop BX}
     Tmp:=VarTabl.Field[InId(NewName)].Adr;
     if Size = 1 then
        Write4($88,$87,Lo(DataBase+Tmp),Hi(DataBase+Tmp))
     else
         Write4($89,$87,Lo(DataBase+Tmp),Hi(DataBase+Tmp));
   end;
   end
   else
    Error(7,CurWord);
 end;
{============================XPRS=============================}
Procedure XPRS;  {Компилирование выражений}
 begin
  X2;
  While CurWord[1] in ['+','-'] do
   begin
    Write1($50);                                      {Push AX}
    if not (CurWord[1] in ['+','-']) then Error(2,'"+" или "-"');
    ToStack(Ord(CurWord[1]));
    CurWord:=NextWord;
    X2;
    Write1($5B);                                      {Pop BX}
    case Chr(Lo(FromStack)) of
      '+':Write2($03,$C3);                            {Add AX,BX}
      '-':Write3($93,$2B,$C3);                        {XCRG AX,BX ; Sub AX,BX}
    end;
   end;
 end;
{========================== X2 ===============================}
Procedure X2;  {Компилирование выражений}
 begin
  X3;
  While CurWord[1] in ['*','/'] do
   begin
    Write1($50);                                      {Push AX}
    if not (CurWord[1] in ['*','/']) then Error(2,'"*" или "/"');
    ToStack(Ord(CurWord[1]));
    CurWord:=NextWord;
    X3;
    Write1($5B);                                      {Pop BX}
    case Chr(Lo(FromStack)) of
      '*':Write2($F7,$E3);                            {Mul AX,BX}
      '/':Write3($93,$F6,$F3);                        {XCRG AX,BX ; Div AX,BX}
    end;
    end;
 end;
{============================ X3===========================}
Procedure X3;    {Компилирование выражений}
var
    Code,I,TmpInt:integer;
    Tmp:word;
    NewName:string;
  begin
  if CurWord='CON' then  {Ввод значения переменной}
   begin
    TmpInt:=OutPtr-ReadAdr+3;
    TmpInt:=-TmpInt;
    Write3($E8,Lo(TmpInt),Hi(TmpInt));
    CurWord:=NextWord
   end
  else
  if CurWord[1]='"' then         {Проверка на символ}
   begin
       CurWord:=NextWord;
       Write4($2A,$E4,$B0,Ord(InpStr[InpPtr-1]));
       if NextWord<>'"' then Error(2,'"');
       CurWord:=NextWord;
   end
  else
  if CurWord[1] in ['0'..'9'] then  {Провека на цифру}
   begin
    Val(CurWord,I,code);
    if Code<>0 then Error(6,'числа');
    Write3($B8,Lo(I),Hi(I));  {mov AX,CurWord}
    CurWord:=NextWord;
   end
  else
   if CurWord='(' then        {Проверка вложенности выражений}
    begin
     CurWord:=NextWord;
     XPRS;
     if CurWord<>')' then Error(2,')');
     CurWord:=NextWord;
    end
   else
    if InId(CurWord)<>0 then
     begin
      NewName:=CurWord;
      CurWord:=NextWord;
      if CurWord='[' then    {Проверка на массив}
       begin
         Write1($50);                                 {Push AX}
         CurWord:=NextWord;
         XPRS;
         Write3($2D,$01,$00);
         if Types[VarTabl.Field[InId(NewName)].Tip].Size=2 then
          Write2($D1,$E0);                            {SHL AX,1}
         Write2($8B,$D8);                             {mov BX,AX}
         Write1($58);                                 {Pop AX}
         if CurWord<>']' then Error(2,']');
         CurWord:=NextWord;
       end
      else  Write2($2B,$DB);                          {SUB BX,BX}
      Tmp:=VarTabl.Field[InId(NewName)].Adr;
 {  if not Types[VarTabl.Field[InId(NewName)].Tip].Arif then Error(7,'');}
      if Types[VarTabl.Field[InId(NewName)].Tip].Size = 1 then
       begin
         Write4($8A,$87,Lo(DataBase+Tmp),Hi(DataBase+Tmp));
         Write2($B4,$00);                              {mov AH,0}
       end
      else
         Write4($8B,$87,Lo(DataBase+Tmp),Hi(DataBase+Tmp));
     end
    Else Error(8,CurWord);
 end;
{||||||||||||||||||||||||MAIN|||||||||||||||||||||||||||||||||}
begin
 StrNum:=1;
 if ParamCount<1 then {Проверка парамаетров файла}
  begin
   WriteLn('Формат вызова COMPILER [Имя файла].PRG');  {Если нет параметров}
   Halt(1);
  end;
 InpFileName:=ParamStr(1);
 VarTabl.FieldNum:=0;      {Установка начальных значений}
 Address:=0;
 InpPtr:=0;
 OutPtr:=0;
 StackPtr:=0;
 Assign(InpF,InpFileName); {Связывание  файла и переменной}
 Reset(InpF,1);
 BlockRead(InpF,InpStr,SizeOf(InpStr),InpSize); {Чтение файла}
 Close(InpF);
 Prog;                     {Компилирование программы}
 I:=1;
 OutFileName:='';
 while (inpfilename[I]<>'.')and(I<Length(InpFileName))do
  begin
   OutFileName:=OutFileName+InpFileName[I];
   Inc(I);
  end;
 Assign(OutF,OutFileName+'.com');
 writeln('Компиляция успешно завершена');
 Rewrite(OutF,1);
 BlockWrite(OutF,OutStr,OutPtr); {Запись полученного кода}
 Close(OutF);
end.